(defpackage :events
  (:use :cl)
  (:nicknames :e)
  (:export event
           key-event
           key
           drag-and-drop-event
           drag-event
           source
           target
           click-event
           motion-event
           enter
           leave
           x y
           button
           handle-mouse-press
           click-node
           mouse-motion))
           
(in-package :events)

(defclass event ()
  ()
  (:documentation "A box event."))

(defclass key-event (event)
  ((key :initarg :key :accessor key)))

(defclass location-mixin ()
  ((x :initarg :x :accessor x)
   (y :initarg :y :accessor y)))

(defclass button-mixin ()
  ((button :initarg :button :accessor button)))  

(defclass drag-and-drop-event (event)
  ((source :initarg :source :accessor source)
   (target :initarg :target :accessor target)))

(defclass drag-event (event location-mixin button-mixin)
  ((source :initarg :source :accessor source)
   (button :initarg :button :accessor button)))

(defclass motion-event (event location-mixin)
  ((enter :initarg :enter :accessor enter)
   (leave :initarg :leave :accessor leave)))

(defclass click-event (event location-mixin button-mixin)
  ((target :initarg :target :accessor target)))

;; (exp:define-event-translation leave motion-event node)

;; (exp:define-event-translation enter motion-event node)

;; (exp:define-event (click-event click-node) (event location-mixin button-mixin)
;;   ((target :initarg :target :accessor target))
;;   (node))

(defun dispatch (view event)
  (when (and (slot-boundp view 'd:event-callback)
             (u:funcallable (d:event-callback view)))
    (funcall (d:event-callback view) view event)))

(defun handle-drag (view root source)
  (labels ((ignore (&rest args) (declare (ignore args)))
           (release (tv button x y)
             (declare (ignore tv))
             (multiple-value-setq (x y) (gwee:translate-coordinates x y gwee:*top-view* view))
             (let ((node (d:find-if-on-tree (lambda (n)
                                              (geom:insidep n x y))
                                            root
                                            :from-end t)))
               (if (eq source node)
                   (throw 'event (make-instance 'click-event :x x :y y :target source :button button))
                   (throw 'event (make-instance 'drag-and-drop-event
                                                :source source
                                                :target node)))))
           (motion (tv state x y xrel yrel)
             (declare (ignore tv x y))
             (when (and (slot-boundp view 'd:event-callback)
                        (u:funcallable (d:event-callback view)))
               (funcall (d:event-callback view) view
                        (make-instance 'drag-event
                                       :source source :button state
                                       :x (+ (geom:x source)
                                             xrel)
                                       :y (+ (geom:y source)
                                             yrel))))))
    (let ((event (catch 'event
                   (gwee:dispatch-events :key-press #'ignore
                                         :key-release #'ignore
                                         :mouse-press #'ignore
                                         :mouse-release #'release
                                         :mouse-motion #'motion))))
      (when event (dispatch view event))
      t)))

(defun handle-mouse-press (view root button x y)
  (let ((source (d:find-if-on-tree (lambda (n)
                                     (geom:insidep n x y))
                                   root
                                   :from-end t)))
    (when source
      (if (d:allow-dragging-p view)
          (handle-drag view root source)
          (dispatch view
                    (make-instance 'click-event
                                   :x x :y y
                                   :button button
                                   :target source)))
      t)))

(defmethod gwee:mouse-press-event ((view d:diagram-view) button x y)
  ;; First check if a child view can handle it. This allows the keypad
  ;; to accept clicks.
  (or (call-next-method)
      (when (d:root view)
        (handle-mouse-press view (d:root view) button x y))))

(defmethod gwee:mouse-press-event ((view sandbox:sandbox-view) button x y)
  (unless (call-next-method)
    (or (and (d:root view)
             (e:handle-mouse-press view (d:root view) button x y))
        (loop for f in (sandbox:floaters view)
             until (e:handle-mouse-press view f button x y)))))
      
(defmethod gwee:key-press-event ((view d:diagram-view) key)
  (when (and (slot-boundp view 'd:event-callback)
             (u:funcallable (d:event-callback view)))
    (funcall (d:event-callback view) view (make-instance 'key-event :key key))))

(defmethod gwee:mouse-motion-event ((view d:diagram-view) state x y xrel yrel)
  ;; First check if a child view can handle it. This allows the keypad
  ;; to accept motion events.
  (or (call-next-method)
      (when (and (slot-boundp view 'd:event-callback)
                 (u:funcallable (d:event-callback view)))
        (let ((new (d:find-if-on-tree (lambda (node)
                                        (geom:insidep node x y))
                                      (d:root view)
                                      :from-end t))
              (old (d:find-if-on-tree (lambda (node)
                                        (geom:insidep node (- x xrel) (- y yrel)))
                                      (d:root view)
                                      :from-end t)))
          (unless (eq new old)
            (funcall (d:event-callback view) view (make-instance 'motion-event
                                                                 :x x :y y
                                                                 :leave old
                                                                 :enter new))))
        t)))

(defmethod gwee:mouse-enter-event ((view d:diagram-view) state x y xrel yrel)
  (when (and (slot-boundp view 'd:event-callback)
             (u:funcallable (d:event-callback view)))
    (let ((new (d:find-if-on-tree (lambda (node)
                                    (geom:insidep node x y))
                                  (d:root view)
                                  :from-end t)))
      (funcall (d:event-callback view) view (make-instance 'motion-event
                                                           :x x :y y
                                                           :leave nil
                                                           :enter new)))))

(defmethod gwee:mouse-leave-event ((view d:diagram-view) state x y xrel yrel)
  ;; (print `(mooooo cow))
  ;; (when (slot-boundp view 'd:event-callback)
  ;;   (let ((old (d:find-if-on-tree (lambda (node)
  ;;                                   (geom:insidep node (- x xrel) (- y yrel)))
  ;;                                 (d:root view)
  ;;                                 :from-end t)))
  ;;     (funcall (d:event-callback view) view (make-instance 'motion-event
  ;;                                                          :x x :y y
  ;;                                                          :leave old
  ;;                                                          :enter nil))))
  )

(exp:define-event-match mouse-motion (trial
                                      (event motion-event))
  (let ((em (when (enter event) (d:id (enter event))))
        (lm (when (leave event) (d:id (leave event)))))
    (list :enter em :leave lm)))

(exp:define-event-match click-node (trial
                                    (event click-event))
  (d:id (target event)))
